home *** CD-ROM | disk | FTP | other *** search
/ Libris Britannia 4 / science library(b).zip / science library(b) / PROGRAMM / PASCAL / 0189.ZIP / PICTOFRM.PAS < prev    next >
Pascal/Delphi Source File  |  1986-02-09  |  11KB  |  302 lines
  1. (***************************************************************)
  2. (*                                                             *)
  3. (*        FILER A LA PASCAL DATA BASE SOURCE CODE FILE         *)
  4. (*                                                             *)
  5. (*        (C) 1985 by  John M. Harlan                          *)
  6. (*                     24000 Telegraph                         *)
  7. (*                     Southfield, MI. 48034                   *)
  8. (*                                                             *)
  9. (*     The FILER GROUP of programs is released on a "FREE      *)
  10. (*     SOFTWARE" basis.  The recipient is free to examine      *)
  11. (*     and use the software with the understanding that if     *)
  12. (*     the FILER GROUP of programs prove to be of use and      *)
  13. (*     value,  a contribution to the author is encouraged.     *)
  14. (*                                                             *)
  15. (*     While reasonable effort has been made to ensure the     *)
  16. (*     reliability of the FILER GROUP of programs, no war-     *)
  17. (*     ranty is given. The recipient uses the programs at      *)
  18. (*     his own risk  and in no event shall the author be       *)
  19. (*     liable for damages arising from their use.              *)
  20. (*                                                             *)
  21. (*                                                             *)
  22. (***************************************************************)
  23.  
  24.  
  25. program pictofrm;  { ONE OF THE FILER GROUP OF PROGRAMS }
  26. { CONVERTS PICTURE OF DATA BASE SCREEN TO XXX.FRM FILE }
  27. { PICTOFRM.PAS  VERSION 2.0 }
  28. { MAY 20, 1985 }
  29.  
  30. { Formatted 2/7/86 by Doug Stevens using Pformat and the Turbo
  31.   editors global search/replace. Original version was 100%
  32.   upper case and very hard to read. }
  33.  
  34. label QUIT;
  35.  
  36. type
  37.   NameStr   =  string[12];
  38.   String79  =  string[79];
  39.  
  40. var
  41.   x  :  integer;                  { POSITION IN SCREEN DATA LINE }
  42.   y  :  integer;                     { LABEL & DATA ARRAY NUMBER }
  43.   z  :  integer;                           { SCREEN LINE COUNTER }
  44.  
  45.   w, pointer, labelstart,
  46.   labelend, datastart,dataend,
  47.   decpointer,wholedigits,
  48.   wholeend, commas, lastline,
  49.   arraycount, blockingfactor              :  integer;
  50.  
  51.   lab, data,
  52.   ascii, fileexists                       :  boolean;
  53.  
  54.   line      :  array [1..30] of String79;
  55.   work      :  array [1..79] of char;
  56.   info      :  String79;
  57.   labelname :  String79;
  58.   filename  :  string[12];
  59.   ch        :  char;
  60.  
  61.   labellength, datalen,dataform,
  62.   row,column                           :  array[1..32] of integer;
  63.   lblname                              :  array[1..32] of String79;
  64.  
  65.   source, screenform                   : text;
  66. {===============================================================}
  67. {                       FUNCTION EXIST                          }
  68. {===============================================================}
  69. function Exist(filename : NameStr) : boolean;
  70. var
  71.   fil    :  file;
  72.   status : Integer;
  73. begin
  74.   Assign(fil,filename);
  75.   {$I-}
  76.   reset(fil);
  77.   {$I+}
  78.   Exist := (IOResult = 0);
  79. {$I-} Close(fil); status := IOResult; {$I+} (* Required by Turbo 3.x *)
  80. end;                                        (* Added by Doug Stevens *)
  81. {===============================================================}
  82. {                  STORE LABEL & DATA PROCEDURE                 }
  83. {===============================================================}
  84. procedure StoreLabDat;
  85. begin
  86.   data := false;
  87.   lab := false;
  88.   lblname[y] := labelname;                { SAVE LABEL IN ARRAY }
  89.  
  90.   if decpointer = 0 then           { NO DECIMAL POINT IN NUMBER }
  91.     begin
  92.       wholeend := dataend;
  93.       decpointer := dataend ;
  94.     end;
  95.   if ascii = true then                       { ASCII DATA FOUND }
  96.     begin
  97.       dataform[y] := 15;
  98.       commas := 0;
  99.     end
  100.   else
  101.     begin   { PROCESS FOR NUMERIC DATA ONLY }
  102.       dataform[y] := dataend-decpointer;
  103.       wholedigits := wholeend - datastart;
  104.       if wholedigits > 7 then commas := 2
  105.       else
  106.         begin
  107.           if wholedigits >3 then commas := 1 else commas := 0;
  108.         end;
  109.     end;  { IF ASCII...ELSE BEGIN }
  110.   datalen[y] := dataend - datastart + 1 - commas;
  111.   row[y] := z;
  112.   column[y] := labelstart;
  113.   y := y + 1;  { INCREMENT ARRAY COUNTER }
  114.   dataend := 0;
  115.   datastart := 0;
  116.   decpointer := 0;
  117.   labelname := '';
  118.   ascii := false;
  119. end;
  120.  
  121. {===============================================================}
  122. {                       MAIN PROGRAM                            }
  123. {===============================================================}
  124.  
  125. begin
  126.   repeat
  127.     ClrScr;
  128.     GotoXY(1,24);
  129.     writeln('"PICTOFRM" CONVERTS FILES FROM XXX.PIC TO XXX.FRM');
  130.     writeln;
  131.     write('ENTER FILENAME OF PICTURE FILE : ');
  132.     readln(filename);
  133.     x := pos('.',filename);
  134.     if x <> 0 then filename := copy(filename,1,x-1);
  135.     if filename = 'END' then goto QUIT;   { Quick and dirty exit. }
  136.     filename := filename + '.PIC';
  137.     fileexists := Exist(filename);
  138.   until fileexists = true;
  139.   Assign (source,filename);
  140.   reset(source);
  141.  
  142.   z := 1;  { LINE NUMBER IN SCREEN }
  143.   ClrScr;
  144.   while not eof(source) do
  145.     begin
  146.       readln(source,line[z]);
  147.       writeln(line[z]);
  148.       z := z+1;
  149.     end;
  150.   lastline := z-1;
  151.   write('ENTER ANY KEY TO CONTINUE ');
  152.   read(Kbd,ch);
  153.   DelLine;
  154.   writeln;
  155.  
  156. {===============================================================}
  157. {                    TRANSLATE SCREEN DATA                      }
  158. {===============================================================}
  159.  
  160.   y := 1;  { ARRAY COUNTER }
  161.   z := 1;  { SCREEN LINE COUNTER }
  162.  
  163.     while z <= lastline do
  164.       begin
  165.         datastart := 0;
  166.         dataend := 0;
  167.         decpointer := 0;
  168.         lab := false;
  169.         data := false;
  170.         labelname := '';
  171.         ascii := false;
  172.  
  173.         for x := 1 to length(line[z]) do
  174.           begin
  175.             if lab = false then
  176.               begin
  177.                 if line[z][x] <> ' ' then
  178.                   begin
  179.                     labelstart := x;
  180.                     lab := true;         { FIRST CHAR OF LABEL FOUND }
  181.                     labelname := labelname + line[z][x];
  182.                   end;
  183.               end
  184.             else
  185.               begin                                      { LAB = TRUE}
  186.                 if data = false then             { PROCESS LABEL INFO }
  187.                   begin                   { LAB = TRUE & DATA = FALSE }
  188.                     if line[z][x] = ':' then
  189.                       begin
  190.                         data := true;
  191.                       end
  192.                     else             { WE HAVE ANOTHER CHAR OF LABEL }
  193.                       begin
  194.                         labelname := labelname + line[z][x];
  195.                       end;
  196.                   end
  197.                 else                       { LAB = TRUE & DATA = TRUE }
  198.                   begin                { PROCESS NUMERIC INFORMATION }
  199.                     if datastart = 0 then
  200.                       begin
  201.                         if line[z][x] <> ' ' then
  202.  
  203.  
  204.                           begin
  205.                             datastart := x;
  206.                             if UpCase(line[z][x]) in ['A'..'Z'] then ascii := true;
  207.                             if line[z][x] = '.' then
  208.                               begin
  209.                                 decpointer := x;
  210.                                 wholeend := x-1;
  211.                               end;
  212.                           end;
  213.  
  214.  
  215.                       end
  216.                     else
  217.                       begin
  218.                         if x = length(line[z]) then
  219.                           begin
  220.                             dataend := x;
  221.                             StoreLabDat;            {  END OF LINE FOUND  }
  222.                           end
  223.                         else
  224.                           begin
  225.                             if line[z][x] = '.' then
  226.                               begin
  227.                                 decpointer := x;
  228.                                 wholeend := x-1;
  229.                               end;
  230.                             if line[z][x] = ' ' then
  231.                               begin
  232.                                 dataend := x-1;
  233.                                 StoreLabDat; {  SPACE AFTER LABEL FOUND  }
  234.                               end;
  235.                           end;  { IF X .. ELSE BEGIN }
  236.                       end;  { IF DATASTART .. ELSE BEGIN }
  237.                   end;  { IF DATA ... ELSE BEGIN }
  238.               end;  { IF LAB ... ELSE BEGIN }
  239.           end;  { FOR X ... BEGIN }
  240.         z := z + 1;
  241.       end;  { WHILE .. BEGIN }
  242.       close(source);
  243.  
  244.       x := pos('.',filename);
  245.       if x <> 0 then filename := copy(filename,1,x-1);
  246.       filename := filename + '.FRM';
  247.       Assign(screenform,filename);
  248.       rewrite(screenform);
  249.       arraycount := y-1;
  250.  
  251.       for x := 1 to y-1 do
  252.         begin
  253.           str(row[x]:3,info);
  254.           write (screenform,'ROW',info);
  255.           write ('ROW',info);
  256.           str(column[x]:3,info);
  257.           write (screenform,', COL',info);
  258.           write (', COL',info);
  259.           str(dataform[x]:3,info);
  260.           write (screenform,', FORM',info);
  261.           write (', FORM',info);
  262.           str(datalen[x]:4,info);
  263.           write (screenform,', LEN',info);
  264.           write (', LEN',info);
  265.           write (screenform,', MISC ___');
  266.           write (', MISC ___');
  267.           writeln (screenform,', LABEL >',lblname[x],'<');
  268.           writeln (', LABEL >',lblname[x],'<');
  269.         end;
  270.         writeln;
  271.         write('ENTER ANY KEY TO CONTINUE ');
  272.         read(Kbd,ch);
  273.         DelLine;
  274.         writeln;
  275. writeln('BEGINNING WITH A PICTURE OF THE FILE, "PICTOFRM" HAS TRANSLATED');
  276. writeln('THIS INFORMATION INTO AN INTERMEDIATE FORM AND STORED IT IN A');
  277. writeln('FILE WITH THE SAME NAME AND THE FILE EXTENSION ".FRM".');
  278. writeln;
  279. writeln('THIS FILE MAY NOW BE EDITED WITH ANY EDITOR SUCH AS WORDSTAR');
  280. writeln('TO REVISE THE ORDER OF THE FIELDS WITHIN THE FILE.');
  281. writeln;
  282. writeln('FINALLY, TO CONVERT THE ".FRM" INTERMEDIATE FILE INTO A ".DAT"');
  283. writeln('FILE THAT CAN BE USED BY THE FILER GROUP OF PROGRAMS, USE THE');
  284. writeln('PROGRAM "FRMTODAT".');
  285.  
  286.       z := 0;
  287.       for x :=1 to arraycount do
  288.         z := z + datalen[x];
  289.       writeln;
  290.       writeln('RECORD LENGTH : ',z,' BYTES');
  291.       blockingfactor := 256 div z;
  292.       writeln('BLOCKING FACTOR : ',blockingfactor);
  293.       w := 256 div (blockingfactor + 1) -z;
  294.       writeln('BYTES LEFT IN BLOCK : ',256-z*blockingfactor);
  295.       write('CHANGE RECORD LENGTH BY ',w);
  296.       writeln(' BYTES TO INCREASE BLOCKING FACTOR');
  297.  
  298.       close(screenform);
  299. QUIT:
  300. end.
  301.  
  302.